home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / sllist.zip / SLLIST.PAS < prev   
Pascal/Delphi Source File  |  1989-03-10  |  12KB  |  499 lines
  1. {$A+,B+,D+,E+,F-,I+,L+,N-,O-,R+,S+,V-}
  2. {$M 8192,0,655360}
  3.  
  4. program SinglyLinkedList;
  5.  
  6. uses crt,dos;
  7. type
  8.  _str80         = string[80];
  9.  _str30         = string[30];
  10.  _str20         = string[20];
  11.  _wordP         = ^_wordrec;
  12.  _wordrec       = record
  13.                     index  : word;
  14.                     aword  : _str20;
  15.                     next   :_wordP;
  16.                   end;
  17.  
  18.   _infiletype1  = text;
  19.   _infiletype2  = file of _wordrec;
  20.   _outfiletype1 = text;
  21.   _outfiletype2 = file of _wordrec;
  22.  
  23. var
  24.   start,last  : _wordP;
  25.   t,t2        : integer;
  26.   infile1     : _infiletype1;
  27.   infile2     : _infiletype2;
  28.   outfile1    : _outfiletype1;
  29.   outfile2    : _outfiletype2;
  30.   infilename,
  31.   outfilename : _str30;
  32.   done        : boolean;
  33.   savindex    : word;
  34.   savattr     : byte;
  35.  
  36. function MenuSelect:char;
  37. var ch:char;
  38. begin
  39.   writeln;
  40.   writeln('   1. Enter a new word.');
  41.   writeln('   2. Delete a word.');
  42.   writeln('   3. Display the list of words.');
  43.   writeln('   4. Search for a word.');
  44.   writeln('   5. Save the word list to disk.');
  45.   writeln('   6. Load a word list from disk.');
  46.   writeln('   7. Load words, then Select random words and save to disk.');
  47.   writeln('   0. Quit.');
  48.   repeat
  49.     write(#13);
  50.     write('                       Enter choice...');
  51.     ch := upcase(readkey);
  52.   until (ch in ['0'..'7']);
  53.   MenuSelect := ch;
  54. end; (* MenuSelect *)
  55.  
  56. function Mono : boolean;
  57. var
  58.   Regs : Registers;
  59. begin
  60.   intr(17,dos.Registers(Regs));
  61.   if (Regs.AX and $0030) = $30 then Mono := true
  62.   else Mono := false
  63. end;(* Mono *)
  64.  
  65. procedure CursorOn;
  66. var    Regs : Registers;
  67. begin
  68.   with Regs do begin
  69.       AX := $0100;
  70.       if Mono then CX := $0B0C else CX := $0607;
  71.     end;
  72.   intr(16,Regs);
  73. end; (* CursorOn *)
  74.  
  75. function Store(info,start : _wordP;
  76.                  var last : _wordP):_wordP;
  77. (*** stores entries in sorted order ***)
  78. var
  79.   old,top  : _wordP;
  80.   done     : boolean;
  81. begin
  82.   top  := start;
  83.   old  := NIL;
  84.   done := false;
  85.  
  86.   if start = NIL then
  87.   begin                       (* first element in the list *)
  88.     info^.next  := NIL;
  89.     last  := info;
  90.     Store := info;
  91.   end else
  92.   begin
  93.     while (start <> NIL) and (not done) do
  94.     begin
  95.       if (start^.aword < info^.aword) then
  96.       begin
  97.         old := start;
  98.         start := start^.next
  99.       end else
  100.       begin                (* goes in the middle *)
  101.         if old <> NIL then
  102.         begin
  103.           old^.next  := info;
  104.           info^.next := start;
  105.           Store := top;    (* keep same starting point *)
  106.           done := true
  107.         end else
  108.         begin
  109.           info^.next := start; (* new first element *)
  110.           Store := info;
  111.           done := true
  112.         end;
  113.       end;
  114.     end; (*while *)
  115.     if (not done) then
  116.       begin
  117.         last^.next := info;    (* goes on end *)
  118.         info^.next := NIL;
  119.         last := info;
  120.         Store := top
  121.       end;
  122.   end;
  123. end;(* Store *)
  124.  
  125. function Delete(VAR start : _wordP;
  126.            item,prioritem : _wordP) : _wordP;
  127. begin
  128.   clrscr;
  129.   writeln('The word #',item^.index,' "',item^.aword,'" will be deleted.');
  130.   repeat until keypressed;
  131.   if (prioritem <> NIL) then
  132.     prioritem^.next := item^.next
  133.   else start := item^.next;
  134.   Delete := start
  135. end; (* Delete *)
  136.  
  137. function GetPrior(start_ : _wordP;
  138.        VAR item_, prior_ : _wordP;
  139.                        x : word) : _wordP;
  140.  
  141. begin
  142.                                  
  143.   if (x = 1) then          (* Then "x" is the first in the list or index #1 *)
  144.     begin
  145.       prior_  := NIL;
  146.       item_   := start
  147.     end else
  148.     begin
  149.       prior_ := start;
  150.       item_  := start^.next;
  151.       while (item_^.index) < x  do
  152.       begin
  153.         prior_  := item_;                   (* *)
  154.         item_   := item_^.next;
  155.         write(prior_^.aword);
  156.         write(item_^.aword)
  157.       end;
  158.     end;
  159.  
  160.   GetPrior := prior_
  161. end; (* GetPrior *)
  162.  
  163. procedure Remove{(start : _wordP)};
  164. var
  165.   ix : word;
  166.   item,prior : _wordP;
  167. begin
  168.   writeln;
  169.   writeln('   Enter the index # of the word to delete from list OR');
  170.   write  ('                                      Enter a 0 to quit: ');
  171.   read(ix);
  172.   if (ix = 0) then exit;
  173.   writeln;
  174.   prior := GetPrior(start,item,prior,ix);
  175.   start := Delete(start,item,prior)
  176. end; (* Remove *)
  177.  
  178. procedure Enter;
  179. var
  180.   info : _wordP;
  181.   done : boolean;
  182. begin
  183.   done := false;
  184.   repeat
  185.     New(info);               (** get a new record **)
  186.     writeln;
  187.     write('   Enter a word to enter into the list: ');
  188.     readln(info^.aword); writeln;
  189.     if (length(info^.aword)) = 0 then done := true
  190.     else
  191.     begin
  192.       start := Store(info,start,last);         (** Store it **)
  193.     end;
  194.   until (done)
  195. end; (* Enter *)
  196.  
  197. procedure Display(start : _wordP);
  198. begin
  199.   window(1,1,80,25); clrscr;
  200.   writeln;writeln;
  201.   if (start = NIL) then
  202.     writeln('The list is empty!!!')
  203.     else while (start <> NIL) do
  204.     begin
  205.       with start^ do
  206.         begin
  207.           write(index:5,' ',aword,' ');
  208.         end;
  209.       start := start^.next;
  210.     end;
  211.   writeln; writeln('Press [Enter] to continue...');readln; writeln;
  212.   textattr := savattr;
  213.   clrscr;
  214. end; (* Display *)
  215.  
  216. function Search( start : _wordP;
  217.                 ix     : word         ):_wordP;
  218. var
  219.   done : boolean;
  220. begin
  221.   done := false;
  222.   while (start <> NIL) and (not done) do
  223.     begin
  224.       if (ix = start^.index) then
  225.         begin
  226.           Search := start;
  227.           done := true
  228.         end else
  229.           start := start^.next
  230.     end;
  231.   if (start = NIL) then
  232.     search := NIL;  (* not in list *)
  233. end; (* Search *)
  234.  
  235. procedure Find1;
  236. var
  237.   loc   : _wordP;
  238.   inx : word;
  239. begin
  240.   clrscr;
  241.   writeln;
  242.   writeln('   Enter the index # of the word to find OR');
  243.   write  ('                            enter 0 to quit: ');
  244.   read(inx);
  245.   if inx = 0 then exit;
  246.   writeln;
  247.   loc := Search(start,inx);
  248.   if (loc <> NIL) then
  249.     begin
  250.       writeln('   Word # ',inx,' is ',loc^.aword);
  251.       writeln;
  252.       writeln('   Press any key to continue...');repeat until keypressed;
  253.     end
  254.   else
  255.   begin
  256.     writeln('   Word # ',inx,' is not in the list!');
  257.     writeln;
  258.     writeln('   Press any key to continue...');repeat until keypressed;
  259.   end;
  260. end; (* Find1 *)
  261.  
  262. {
  263. procedure Find2;
  264. var
  265.   loc  :_addrPointer;
  266.   name :_str80;
  267. begin
  268.   writeln;
  269.   write('Enter Name to find: ');
  270.   readln(name); writeln;
  271.   loc := Search(start,name);
  272.   if (loc <> NIL) then
  273.     begin
  274.       writeln('■',loc^.name,'■');
  275.       writeln('■',loc^.street,'■');
  276.       writeln('■',loc^.city,'■');
  277.       writeln('■',loc^.state,'■');
  278.       writeln('■',loc^.zip,'■'); (* writeln; *)
  279.     end
  280.   else
  281.     writeln('Name not in list!'); writeln;
  282.   writeln('Press [Enter] to continue...');readln;
  283. end; (* Find2 *)
  284. }
  285.  
  286. procedure Save1(var fil   : _outfiletype1;
  287.                     start : _wordP);
  288. begin
  289.   window(1,1,80,25);
  290.   rewrite(fil);
  291.   while(start <> NIL) do
  292.     begin
  293.       writeln(fil,start^.aword);
  294.       with start^ do
  295.         begin
  296.           write(index:5,' ',aword,' ');
  297.         end;
  298.       start := start^.next
  299.     end;
  300.   close(fil);
  301.   writeln('   Press any key to continue...');repeat until keypressed;
  302.   textattr := savattr; clrscr;
  303. end; (* Save *)
  304.  
  305. procedure Save2(var fil   : _outfiletype2;
  306.                     start :_wordP);
  307. begin
  308.   writeln;
  309.   writeln('Saving file...');
  310.   rewrite(fil);
  311.   while(start <> NIL) do
  312.     begin
  313.       write(fil,start^);
  314.       { with start^ do }
  315.         { begin }
  316.         { end; }
  317.       start := start^.next
  318.     end;
  319.   close(fil);
  320.   writeln;writeln('Press [Enter] to continue...');readln;
  321. end; (* Save2 *)
  322.  
  323. function Load1(var fil   : _infiletype1;         (*** text file ***)
  324.                    start : _wordP):_wordP;
  325. (***** returns a pointer to start of the list *****)
  326. var
  327.   temp,temp2 :_wordP;
  328.   first      : boolean;
  329.   line       : _str20;
  330.   indx       : word;
  331. begin
  332.   writeln;
  333.   writeln('                       Loading file...');
  334.   reset(fil);
  335.   while (start <> NIL) do    (* free memory,